perm filename GETPTS.F4[PAG,LCS] blob
sn#598961 filedate 1981-07-12 generic text, type T, neo UTF8
00100 SUBROUTINE GETPTS(NX,RN,KWDS)
00200 C 'NX' DOES NOT SEEM TO BE USED
00300 DIMENSION RN(1),KWDS(1)
00400 COMMON/KNR/N(1) /NNP/NP(1) /LLL/LLL
00500 COMMON R2,JA,CENTR,J2,RJQ(18),RX6,JR,L,RDIS
00600 COMMON/POSI/STFF(8),JJ2,JPQ /KJY/ K,J
00700 EQUIVALENCE (R4,RJQ(2)),(R5,RJQ(3))
00800
00900 J=0
01000 K=0
01100 CC JX=JJ2
01200 C GET THE STAFF NUM. (NEG= ALL IN THIS PROG.)
01300 DO 1 M=1,LLL
01400 L=KWDS(M)
01500 IF(R2.LT.0)GO TO 9
01600 IF(RN(L+1).NE.R2)GO TO 1
01700 C NEG R2=ALL STAVES CHECK NOW FOR CORRECT STAFF
01800
01900 9 X=RN(L+3)
02000 IF(X.LT.R4.OR.X.GT.R5)GO TO 2
02100 C NOW P3 IS IN LIMITS
02200 IF(JJ2.LE.0)JJ2=M
02300 J=J+1
02400 CC MOVEI 0,(L)
02500 K=K+1
02600 NP(K)=L
02700 C NP LIST POINTS TO START OF EACH ITEM TO MOVE
02800 N(J)=L+3
02900 C N LIST POINTS TO PARAM TO BE MOVED
03000 C NP IS FOR USE IN JUSTIFY ROUTINE
03100 2 RY=RN(L+1)
03200 C RY IS CODE NUMBER OF ITEM
03300 IF(RY.EQ.2.)GO TO 99
03400 C JUMP IF REST
03500 IF(RY.LT.4)GO TO 1
03600 RZ=RN(L)
03700 C RZ IS WDCNT. CODE 4 IS SOMETIMES =44
03800 IF(RY.NE.44.)GO TO 98
03900 IF(RZ.LE.2.)GO TO 1
04000 GO TO 5
04100 C IF(RZ.LE.2)THEN IT'S A CODE 44 BAR LINE.
04200 C FOUND A LINE
04300 98 IF(RY.GT.7.)GO TO 1
04400 C TWO-ENDED ITEM?
04500 GO TO (4,5,6,7),IFIX(RY)-3
04600 7 IF(RZ.GT.4.)GO TO 1
04700 C FOR TRILL??
04800 4 IF(RZ.GT.3.)GO TO 5
04900 C CHECK WDCNT
05000 GO TO 1
05100 99 RZ=RN(L)
05200 C FOR 'CENTERED' RESTS
05300 GO TO 8
05400 6 IF(RZ.LT.8.)GO TO 8
05500 IF(RN(L+7).LT.0)GO TO 8
05600 C THESE ARE FOR VARIOUS BEAM PARAMS.
05700 IF(RN(L+10).EQ.0)GO TO 8
05800 C IGNORE P8 IF IT IS 0 OR -
05900 X=RN(L+8)
06000 IF(X.LE.0)GO TO 8
06100 IF(X.LT.R4)GO TO 8
06200 IF(X.GT.R5)GO TO 8
06300 C NOW P8 IS IN LIMITS
06400 CALL SETN(L+8,M)
06500 C FIND LOWEST ITEM NUMBER NEEDED
06600 C SAVE POINTER TO P8 FOR MOVING.
06700 8 IF(RZ.LT.7.)GO TO 5
06800 C JUMP IF WDCNT IS .LT. 7
06900 IF(RN(L+9).LE.0)GO TO 5
07000 IF(RY.EQ.2.)GO TO 97
07100 C NEW CENTERED RESTS HAS POSITION IN P9
07200 IF(RN(L+8).NE.0)GO TO 97
07300 IF(RN(L+7).GE.0)GO TO 5
07400 97 X=RN(L+9)
07500 IF(X.LT.R4)GO TO 5
07600 IF(X.GT.R5)GO TO 5
07700 C NOW P9 IS IN LIMITS
07800 CALL SETN(L+9,M)
07900 5 IF(RY.EQ.2.)GO TO 1
08000 X=RN(L+6)
08100 IF(X.LT.R4)GO TO 1
08200 IF(X.GT.R5)GO TO 1
08300 C NOW P6 IS IN LIMITS
08400 CALL SETN(L+6,M)
08500 1 CONTINUE
08600 END
08700
08800 SUBROUTINE SETN(L,M)
08900 COMMON/POSI/STFF(8),JJ2 /KJY/ K,J /KNR/N(1)
09000 IF(JJ2.GT.M)JJ2=M
09100 C FIND LOWEST ITEM NUMBER NEEDED
09200 J=J+1
09300 N(J)=L
09400 END
09500 SUBROUTINE MOVIT(RN,NP,R4,R5,R8,R9)
09600 DIMENSION NP(1),RN(1)
09700 COMMON /KJY/ KD,J
09800 RDIS=(R9-R8)/(R5-R4)
09900 DO 1 K=1,J
10000 L=NP(K)
10100 RA=RN(L)
10200 IF(RA.LT.R4)GO TO 1
10300 IF(RA.GT.R5)GO TO 1
10400 C NOW IN BOUNDS
10500 IF(R9.NE.0)RA=(RA-R4)*RDIS
10600 RN(L)=R8+RA
10700 1 CONTINUE
10800 END
10900
11000 FUNCTION EXTEN(X)
11100 EXTEN=AMOD(X,1.)*10.
11200 END
11300
11400 SUBROUTINE DBAR(K,ITEM,J)
11500 COMMON /XRN/RN(1) /RR/RR /PTR/KWDS(1)
11600
11700 RR=RN(J+3)
11800 C SAVE POSITION OF ITEM. ALSO USED IN ADRST ROUTINE.
11900 DO 82 KY=K+1,ITEM
12000 KZ=KWDS(KY)
12100 IF(RN(KZ+1).NE.4.)GO TO 82
12200 IF(RN(KZ).GT.3.)GO TO 82
12300 C CHECK THE WDCNT
12400 IF(ABS(RR-RN(KZ+3)).GT..5)GO TO 82
12500 C AVOIDS DUPLICATE BARS.
12600 RN(KZ+2)=99.
12700 RN(KZ+1)=0
12800 82 CONTINUE
12900 END
13000
13100
13200 SUBROUTINE ADRST(JWDS,RA)
13300 COMMON /XXX/LK,LP,JY /Q/Q(1) /RR/RR /LLL/LLL
13400 DIMENSION JWDS(1)
13500
13600 Q(LK)=6.
13700 Q(LK+1)=2.
13800 C SET UP THE REST
13900 Q(LK+2)=0
14000 Q(LK+3)=RR-1.
14100 C GET POSITION FROM ROUTINE ABOVE
14200 Q(LK+4)=0
14300 Q(LK+5)=0
14400 Q(LK+6)=0
14500 Q(LK+7)=6.
14600 Q(LK+8)=-1.
14700 C NEXT ADDS A BAR LINE
14800 LK=LK+9
14900 JWDS(LLL+1)=LK
15000 CHECK THIS ******************
15100 Q(LK)=2.
15200 Q(LK+1)=4.
15300 Q(LK+2)=0
15400 Q(LK+3)=RR
15500 Q(LK+4)=RA
15600 LK=LK+5
15700 JWDS(LLL+2)=LK
15800 LLL=LLL+2
15900 END
16000
16100 SUBROUTINE QRN(J,JWDS,K)
16200 DIMENSION JWDS(1)
16300 COMMON RS,JA,REST,J2,RQ(2),R5
16400 COMMON /XRN/RN(1) /PTR/KWDS(1) /XXX/LK /Q/Q(1) /LLL/LLL
16500 COMMON /RCLF/RCLF,CLEF /SF/KL
16600 JA=KWDS(K+1)
16700 LX=LK
16800 DO 7 KY=J,JA-1
16900 Q(LK)=RN(KY)
17000 7 LK=LK+1
17100 IF(KL.EQ.0)GO TO 5
17200 C PUT A 1.0 AS RHYTHM FOR REST OR NOTE
17300 LK=LK+KL-1
17400 Q(LK)=1.
17500 C PUT IT IN PARAM 7 OR 9
17600 CC5 LK=LK+1
17700 5 IF(R5.LT.0)GO TO 2
17800 Q(LX+5)=R5
17900 WDC=3.
18000 3 LK=LK+WDC-Q(LX)
18100 C UPDATE THE MAIN COUNTER
18200 Q(LX)=WDC
18300 GO TO 1
18400 2 IF(RCLF.NE.17.)GO TO 1
18500 Q(LX+6)=CLEF
18600 C GET THE CLEF NUM.
18700 WDC=4.
18800 GO TO 3
18900 1 JWDS(LLL+1)=LK
19000 LLL=LLL+1
19100 END
19200
19300 SUBROUTINE SORT(JWDS)
19400 DIMENSION JWDS(1)
19500 COMMON /LLL/LLL /Q/Q(1) /XRN/RN(1) /PTR/KWDS(1)
19600 I=1
19700 DO 243 K=1,LLL-1
19800 LB=JWDS(K)+1
19900 IF(Q(LB).NE.16.)GO TO 243
20000 IF(Q(LB-1).LT.8.)GO TO 243
20100 JL=JWDS(K-1)
20200 244 Q(LB+2)=Q(JL+3)
20300 243 CONTINUE
20400
20500 C PUTS CONTINUATION OF TEXT IMMEDIATELY AFTER PREV. POS.
20600 C FOR SPACING PROBLEMS BELOW.
20700 M=2
20800 J=1
20900 24 RA=100000.
21000 C POSITION
21100 DO 21 K=1,LLL-1
21200 JL=JWDS(K)+3
21300 R=Q(JL)
21400 IF(R.EQ.100000.)GO TO 21
21500 241 IF(ABS(R-RA).GT..1)GO TO 240
21600 Q(JL)=RA
21700 GO TO 21
21800 CC PUT IN HERE MULTI-VOICE TRAP SOMEDAY
21900 240 IF(R.GT.RA)GO TO 21
22000 C LINES THEM UP
22100 RA=R
22200 CC I=JL-3
22300 I=K
22400 21 CONTINUE
22500 IF(RA.EQ.100000.)RETURN
22600 C JUMP IF ALL SORTED
22700 242 JL=JWDS(I)
22800 LA=JL
22900 N=Q(JL)+3
23000 KWDS(M)=KWDS(M-1)+N
23100 M=M+1
23200 DO 22 K=J,J+N-1
23300 RN(K)=Q(JL)
23400 22 JL=JL+1
23500 J=J+N
23600 Q(LA+3)=100000.
23700 GO TO 24
23800 END
23900
24000 SUBROUTINE SHIFT
24100 COMMON /PX/KPN(1) /Q/Q(1) /LLL/LLL
24200 K=1
24300 L=1
24400 LK=0
24500 221 NN=KPN(K)
24600 IF(Q(NN+1).LT.0)GO TO 321
24700 M=KPN(K+1)
24800 2 Q(L)=Q(NN)
24900 NN=NN+1
25000 IF(NN.GE.M)GO TO 1
25100 L=L+1
25200 GO TO 2
25300 1 LK=LK+1
25400 L=L+1
25500 KPN(LK+1)=L
25600 C SET NEXT POINTER
25700 321 K=K+1
25800 IF(K.LT.LLL)GO TO 221
25900 LLL=LK
26000 END
26100
26200 SUBROUTINE SHFT1(KQ)
26300 COMMON /LLL/L /Q/Q(1) /XRN/RN(1) /PX/KPN(1) /IPG/IPG
26400 L=1
26500 K=1
26600 220 JJ=Q(K)+3
26700 KPN(L)=K
26800 C NEW POINTER
26900 IF(Q(K+1).NE.2.OR.Q(K).LT.6)GO TO 1
27000 JK=JJ+K
27100 IF(Q(JK+1).NE.10.OR.Q(JK).LT.6)GO TO 1
27200 IF(IPG.EQ.0)GO TO 1
27300 C do next only when extracting parts(IPG.NE.0)
27400 M=0
27500 KK=Q(JK)+2
27600 DO 2 N=K,K+KK+JK-1
27700 M=M+1
27800 2 RN(M)=Q(N)
27900 M=JK-K
28000 J=KK-JK
28100 KA=J+K
28200 NA=K
28300 B=RN(M+3)
28400 C SAVE POS. (P3)
28500 DO 3 N=K,KA-1
28600 Q(N)=RN(M)
28700 3 M=M+1
28800 JK=K+J
28900 M=1
29000 A=RN(4)
29100 C POS OF THIS ITEM
29200 Q(NA+3)=A
29300 RN(4)=B
29400 DO 4 N=JK,KK-1
29500 Q(N)=RN(M)
29600 4 M=M+1
29700 C ALL THIS TO FIND NUM AFTER REST.
29800 C GO BACK TO GET RIGHT PNTRS NOW.
29900 GO TO 220
30000 1 K=K+JJ
30100 IF(K.GE.KQ)GO TO 5
30200 L=L+1
30300 GO TO 220
30400 5 L=L+1
30500 KPN(L)=K
30600 END
30700
30800 SUBROUTINE SHFT0(KQ)
30900 COMMON /LLL/L /XRN/RN(1) /Q/Q(1) /XXX/LK /PTR/KWDS(1)
31000 DO 32 K=1,KWDS(L)-1
31100 KQ=KQ+1
31200 32 Q(KQ)=RN(K)
31300 L=1
31400 LK=1
31500 END
31600
31700 SUBROUTINE PSHFT(I)
31800 COMMON /SF/KL /PX/KPN(1) /Q/Q(1) /XRN/RN(1)
31900 M=KPN(I+1)
32000 DO 31 NA=1,M
32100 RN(KL)=Q(NA)
32200 31 KL=KL+1
32300 END
34000
35000 SUBROUTINE STAFF(P0,P1, P3,P4,P5,P6,P7,P8,P9,P10,P11,P12)
35100 COMMON/XRN/RN(1) /PTR/KWDS(1) /SF/KL,RT,KP
35200 KWDS(KP)=KL
35300 KP=KP+1
35400 RN(KL)=P0
35500 RN(KL+1)=P1
35600 RN(KL+2)=RT
35700 RN(KL+3)=P3
35800 RN(KL+4)=P4
35900 RN(KL+5)=P5
36000 IF(P0.LT.4.)GO TO 1
36100 RN(KL+6)=P6
36200 RN(KL+7)=P7
36300 RN(KL+8)=P8
36400 RN(KL+9)=P9
36500 RN(KL+10)=P10
36600 RN(KL+11)=P11
36700 RN(KL+12)=P12
36800 1 KL=KL+3+P0
36900 END
37000
37100 FUNCTION RIGHT(NA,J,JK)
37200 COMMON /PX/KPN(1) /Q/Q(1) /LLL/LLL,LL,I
37300 K=NA+J
37400 N6=NJ
37500 IF(K.GT.0)GO TO 4
37600 RIGHT=Q(4)
37700 RETURN
37800 4 RX=Q(JK+3)
37900 R=Q(JK+2)
38000 JX=1
38100 IF(J.GT.0)JX=I
38200 C FORWARD LOOP
38300 1 R8=CODEN(KPN,K,Q,LA)
38400 IF(R8.EQ.4)GO TO 2
38500 IF(Q(LA+2).NE.R)GO TO 3
38600 IF(R8.EQ.18..OR.R8.EQ.17.)GO TO 2
38700 C JUMP ON KEY SIG OR METER
38800 3 IF(K.EQ.JX)GO TO 5
38900 K=K+J
39000 GO TO 1
39100 5 IF(J.LE.0)RIGHT=RX
39200 RETURN
39300 C SKIP NEXT IF GOING FORWARD IN LOOP (LOOKING TO RIGHT)
39400 C USE ITS OWN POS.-2 IF NOTHING FOUND TO LEFT
39500 C C NOW FOUND ITEM TO LEFT OR RT ON THIS STAFF.
39600 2 RIGHT=Q(LA+3)
39700 END
39800
39900 SUBROUTINE RESTS
40000 COMMON /PX/KPN(1) /Q/Q(1) /LLL/LLL
40100 XLFT=0
40200 SIG=-99
40300 REST=0
40400 K=1
40500 50 JL=KPN(K)
40600 R=Q(JL+1)
40700 IF(XLFT.NE.0)GO TO 5
40800 IF(R.LE.4)XLFT=Q(JL+3)
40900 GO TO 3
41000 5 IF(R.NE.17)GO TO 3
41100 IF(Q(JL+5).EQ.SIG)GO TO 60
41200 SIG=Q(JL+5)
41300 3 IF(R.NE.2)GO TO 231
41400 IF(Q(JL).GE.6)GO TO 7
41500 GO TO 231
41600 7 IF(Q(JL+8).LE.-4)GO TO 231
41700 IF(Q(JL+7).LE.0)GO TO 231
41800 C (IGNORE NON-RHYTH.)
41900 C CATCH BAR REPEAT SIGN
42000 IF(Q(JL+8).EQ.0)GO TO 231
42100 C (WHOLE REST OVER CUE NOTES)
42200 IF(REST.NE.0)GO TO 6
42300 JR=JL+6
42400 C POINTER TO REST NUM.
42500 R=Q(JR+1)
42600 IF(R.LT.5)R=5
42700 Q(JR+1)=R*.6
42800 C REDUCE SIZE OF REST'S TIME SO IT WILL TAKE LESS SPACE.
42900 6 REST=REST+1.
43000 Q(JR+2)=REST
43100 Q(JR-2)=-2.
43200 C (LOWER THE REST'S POS.)
43300 JL=K+2
43400 IF(JL.GE.LLL)RETURN
43500 LB=KPN(JL)
43600 IF(Q(LB+1).NE.2)GO TO 233
43700 C NEXT IS TO COMBINE MEASURES OF REST
43800 IF(Q(LB).LT.6)GO TO 233
43900 C SKIP NON-WHOLE RESTS
44000 N=KPN(JL-1)
44100 IF(Q(N+1).NE.4.)GO TO 233
44200 C IS REST FOLLOWED BY A BAR? OR RHRSL NUM?(COULD BE A PROB. HERE!!!)
44300 C SO IT WON'T BE FOUND NEXT TIME AROUND.
44400 Q(LB+1)=-1.
44500 C CHANGE CODE #
44600 Q(N+1)=-1.
44700 K=JL
44800 GO TO 6
44900 60 Q(JL+1)=-1.
45000 GO TO 231
45100 233 REST=0
45200 231 K=K+1
45300 IF(K.LT.LLL)GO TO 50
45400 END
45500
45600 SUBROUTINE EXCHG(M,N)
45700 DIMENSION M(2),N(2)
45800 J=M(1)
45900 M(1)=M(2)
46000 M(2)=J
46100 J=N(1)
46200 N(1)=N(2)
46300 N(2)=J
46400 END
46500
46600 SUBROUTINE EXCH(J,K)
46700 L=J
46800 J=K
46900 K=L
47000 END
47100
47200 SUBROUTINE INMUS(NAME,EXT,RN,KWDS,JSTFAC)
47300 DIMENSION RN(1),KWDS(1),JSTFAC(1)
47400 CALL GETEXT(NAME,EXT)
47500 CALL EXTIN(JSTFAC,20)
47600 C READ ONLY 20 WDS IN PAGE ONLY****** NOT [=128]
47700 JJ=JSTFAC(19)
47800 C JSTFAC(19) = THE WD CNT.
47900 C ********** CHANGE JSTFAC ARRAY FOR PDP11 ***************
48000 CALL EXTIN(RN,JJ)
48100 C MOVE @15 ;@R ;IF(R(1).NE.INTEGER 1)GO TO I3
48200 C CAIE 1 ;OLD FORMAT ? ***** ASSUMES NEW FORMAT (NO KWDS ARRAY)
48300 C JRST I3 ;NO
48400 C USETI 12,2 ;YES, READ 2ND RECORD AGAIN (12 =CH)
48500 C JSA 16,EXTIN ;CALL EXTIN(RS,128)
48600 C JUMP @12 ;JUMP @KW
48700 C JUMP =17(11) ;JUMP NWDS ;CALL EXTIN(K,J)
48800 C JRST I1 ;GO BACK AND GET R ARRAY
48900 3 N=1
49000 L=1
49100 KWDS(1)=1
49200 4 N=N+RN(N)+3
49300 C HERE'S THE LOOP
49400 C GET WD CNT -2
49500 L=L+1
49600 C UPDATE THE COUNTER OF THE POINTER LIST
49700 KWDS(L)=N
49800 IF(N.LT.JJ)GO TO 4
49900 END
50000
50100 FUNCTION RCURVE(R)
50200 DIMENSION R(1)
50300 C R(1) IS R3 R(4) IS R6, ETC.
50400 X=R(4)-R(1)
50500 RCURVE=R(6)+1.
50600 IF(RCURVE.LT.0)X=X+RCURVE+RCURVE
50700 X=X/25.
50800 C R8=-2=BETWEEN NOTES, =-3=1ST NOTE IS DOTTED.
50900 RCURVE=X+2.+ABS(R(3)-R(2))/10.
51000 IF(R(5).LT.0)RCURVE=-RCURVE
51100 C IF(R7 WAS .LT.0)KEEP IT NEGATIVE.
51200 END
51300
51400 SUBROUTINE SHRNK(K,IT)
51500 COMMON R2,JA,REST,J2,R3,R4,R5,R6,R7,R8,R9
51600 COMMON /PX/KPN(1) /Q/Q(1) /LLL/LLL,LL,I
51700 L10=IT-1
51800 L11=KPN(IT+1)
51900 C END OF Q DATA
52000 C X=Q(L+3)
52100 K2=K
52200 K12=K2
52300 K3=KPN(K2)
52400 K6=K3
52500 C A13=Q(K3+3)
52600 R8=Q(K3+3)
52700 C POS. OF CLEF TO BE MOVED.
52800 K4=KPN(K2+1)
52900 C PTR TO NEXT ITEM
53000 K1=K4
53100 K3=K3-K4
53200 C WDCNT OF DELETE ITEM
53300 K4=K4-KPN(K2+2)
53400 C NEXT +1
53500 K3=K3-K4
53600 C AMOUNT OF CHANGE
53700 C1 K5=KPN(K2+2)
53800 C K5=K5-KPN(K2+1)
53900 C K5=K5+KPN(K2)
54000 C KPN(K2+1)=K5
54100 1 KPN(K2+1)=KPN(K2+2)-KPN(K2+1)+KPN(K2)
54200
54300 IF(K2.EQ.L10)GO TO 4
54400 K2=K2+1
54500 GO TO 1
54600 4 K2=KPN(K2+1)
54700 C LAST PTR
54800 C A7=Q(K6+3)
54900 R4=Q(K6+3)
55000 C POS FOR LATER "MOVE"
55100 2 Q(K6)=Q(K1)
55200 K1=K1+1
55300 IF(K1.EQ.L11)GO TO 5
55400 K6=K6+1
55500 GO TO 2
55600 5 IT=L10
55700 I=L10
55800 C I=LEND (FOR FINAL ENDPOINT)
55900 C R4=A7
56000 C R8=A13
56100 C R8=EXPAND REMAINDER OF LINE TO CLEF POS.
56200 6 LL=0
56300 C LL=0 (NO JUSTIFY)
56400 R5=200.
56500 R2=0
56600 R9=R5
56700 R7=0
56800 CALL PTMOVE(Q,KPN(K12))
56900 END
57000
57100 C SUBROUTINE EXPND(J)
57200 CC TO SHIFT LINE TO RT. WHEN ADDING KSIG.
57300 C COMMON/STF/RSTFAC(8),RSTJ2
57400 C COMMON R2,JA,REST,J2,R3,R4,R5,R6,R7,R8,R9
57500 C COMMON /PX/KPN(1) /Q/Q(1) /LLL/LLL,LL,I
57600 CC?? A5=5.
57700 C R4=7.1*RSTJ2
57800 C K12=J+2
57900 CC GET PTR TO KPN ADD 2 (FOR NOW, ANYWAY)
58000 C R8=0
58100 CC GO MOVE IT
58200 C6 LL=0
58300 CC LL=0 (NO JUSTIFY)
58400 C R5=200.
58500 C R2=0
58600 C R9=R5
58700 C R7=0
58800 C CALL PTMOVE(Q,KPN(K12))
58900 C END